home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / simplify_y.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  5.6 KB  |  151 lines
  1. (herald (front_end simplify_y)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; SIMPLIFY-Y finds all of the recursively bound values that do not reference
  5. ;;; any of the recursive variables and binds them using a normal lambda. Lots
  6. ;;; more could be done.
  7.  
  8. ;;; (PRIMOP/Y <cont>
  9. ;;;           (LAMBDA (C V1 ... Vn)                ; y-lambda
  10. ;;;             (C (LAMBDA (C0)                    ; body-lambda
  11. ;;;                  <body>)
  12. ;;;                (LAMBDA (C1) <value code>)      ; value thunks
  13. ;;;                ...                             ;
  14. ;;;                (LAMBDA (Cn) <value code>))))   ;
  15. ;;;
  16. ;;; V1 to Vn are bound to the results of calling the value thunks.  The
  17. ;;; body-lambda is then called on <cont>.  
  18.  
  19. ;;; This works by marking all of the recursively bound values and then walking
  20. ;;; up the tree from the references to the corresponding variables, unmarking
  21. ;;; nodes until Y-LAMBDA is reached.  The net effect is to mark all of the
  22. ;;; values that do not refer to the variables.  HOIST-NONRECURSIVE-VALUES then
  23. ;;; binds these values with a LET.
  24.  
  25. (define (simplify-y call-node)
  26.   (simplify (call-args call-node))
  27.   (let* ((y-lambda ((call-arg '2) call-node))
  28.          (value-call (lambda-body y-lambda)))
  29.     (walk (lambda (n)
  30.             (set (node-flag n) t))
  31.           (cdr (call-args value-call)))
  32.     (mark-reference-parents y-lambda)
  33.     (cond ;((not (node-flag (car (call-args value-call))))
  34.           ; (if (not (null? (cdr (call-args value-call))))
  35.           ;     (user-message '"Unused variables ..."))
  36.           ; (replace-y-with-body call-node))
  37.           (else
  38.            (hoist-nonrecursive-values call-node y-lambda value-call)))))
  39.  
  40. ;;; REMOVE-LOOP-VALUES is removes the marked values from VALUE-CALL.  These
  41. ;;; are then bound to their corresponding variables by INSERT-LABLE-LETS.
  42. ;;; If there are no remaining recursively bound values the call to PRIMOP/Y
  43. ;;; is removed.
  44.  
  45. (define (hoist-nonrecursive-values call-node y-lambda value-call)
  46.   (let* ((removed (remove-loop-values y-lambda
  47.                                       value-call
  48.                                       (lambda (n) (not (node-flag n)))))
  49. ;                                      (lambda (n) (loop-value? n y-lambda))
  50.          (empty? (null? (cdr (lambda-variables y-lambda))))
  51.          (removed? (not (null? removed))))
  52.     (cond (removed?
  53.            (walk (lambda (n)
  54.                    (set (node-flag (cdr n)) nil))
  55.                  removed)
  56.            (insert-label-lets removed (node-parent call-node))))
  57.     (cond (empty?
  58.            (replace (call-proc call-node)
  59.                     (detach (car (call-args value-call))))
  60.            (replace-call-args call-node
  61.                               (list (detach (car (call-args call-node)))))))
  62.     (or removed? empty?)))
  63.  
  64. ;;; Remove the arguments to CALL that do not answer true to PRED and return
  65. ;;; them and their corresponding variables from L-NODE.
  66.  
  67. (define (remove-loop-values l-node call pred)
  68.   (iterate loop ((vars (lambda-variables l-node))
  69.                  (args (call-args call))
  70.                  (removed '())
  71.                  (n '3))
  72.     (cond ((null? (cdr vars))
  73.            removed)
  74.           ((not (used? (cadr vars)))
  75.            (set (cdr vars) (cddr vars)) ; Evil
  76.            (erase-all (cadr args))
  77.            (set (cdr args) (cddr args)) ; Extremely Evil
  78.            (loop vars args removed n))
  79.           ((not (pred (cadr args)))
  80.            (set (node-role (cadr args)) (call-arg (fx- n '1)))
  81.            (let ((r (cons (cadr vars) (detach (cadr args)))))
  82.              (set (cdr vars) (cddr vars)) ; Evil
  83.              (set (cdr args) (cddr args)) ; Extremely Evil
  84.              (loop vars args (cons r removed) n)))
  85.           (else
  86.            (set (variable-number (cadr vars)) n)
  87.            (set (node-role (cadr args)) (call-arg (fx- n '1)))
  88.            (loop (cdr vars) (cdr args) removed (fx+ n '1))))))
  89.  
  90. ;(define (loop-value? thunk y-lambda)
  91. ;  (let ((node (thunk-value thunk)))
  92. ;    (or (not node)
  93. ;        (lambda-node? node)       ;;; Could check live vars...
  94. ;        (object-node? node)
  95. ;        (and (reference-node? node)
  96. ;             (bound-below? node y-lambda))))))
  97.  
  98. ;(define (bound-below? ref top)  ; NIL if REF is bound by TOP
  99. ;  (let ((binder (variable-binder (reference-variable ref))))
  100. ;    (if (not binder)
  101. ;        nil
  102. ;        (iterate loop ((node ref))
  103. ;          (cond ((eq? node top) nil)
  104. ;                ((eq? node binder) t)
  105. ;                (else
  106. ;                 (loop (node-parent node))))))))
  107.  
  108. (define (insert-label-lets vars-and-thunks parent)
  109.   (walk (lambda (vt)
  110.           (var-gets-thunk-value (car vt) (cdr vt) parent))
  111.         vars-and-thunks))
  112.  
  113. (define (var-gets-thunk-value var thunk parent)
  114.   (let ((new-call (create-call-node '2 '1))
  115.         (cont (create-lambda-node 'p (flist2 nil var '()))))
  116.     (relate call-proc new-call thunk)
  117.     (relate (call-arg '1) new-call cont)
  118.     (move (lambda-body parent)
  119.           (lambda (call)
  120.             (relate lambda-body cont call)
  121.             new-call))))
  122.  
  123. ;;; If THUNK is more than just a simple return splice its body between PARENT
  124. ;;; and PARENT's LAMBDA-BODY.
  125.  
  126. (define (maybe-splice-thunk thunk parent)
  127.   (let* ((v (thunk-value thunk))
  128.          (p (node-parent v))
  129.          (v (detach v)))
  130.     (cond ((neq? p (lambda-body thunk))
  131.            (splice-thunk thunk parent))
  132.           (else
  133.            (erase-all thunk)))
  134.     v))
  135.  
  136. ;;; Put the body of THUNK except its return between lambda-node PARENT and
  137. ;;; its call.
  138.  
  139. (define (splice-thunk thunk parent)
  140.   (move (lambda-body parent)
  141.         (lambda (old-body)
  142.           (replace (node-parent (car (variable-refs (lambda-cont-var thunk))))
  143.                    old-body)
  144.           (detach (lambda-body thunk))))
  145.   (erase-all thunk))
  146.  
  147.  
  148.  
  149.                 
  150.  
  151.